home *** CD-ROM | disk | FTP | other *** search
Text File | 2003-02-09 | 38.9 KB | 1,168 lines |
- ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; The data in this file contains enhancments. ;;;;;
- ;;; ;;;;;
- ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
- ;;; All rights reserved ;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (in-package "MAXIMA")
- (macsyma-module irinte)
- (load-macsyma-macros rzmac)
-
- (DECLARE-TOP (SPECIAL CHECKCOEFSIGNLIST EC-1 R12 1//2 VAR GLOBALCAREFLAG
- ZEROSIGNTEST PRODUCTCASE $RADEXPAND))
-
- (DEFUN HASVAR (EXP) (NOT (FREEVAR EXP)))
-
- (DEFUN ZERP (A) (EQUAL A 0))
-
- (DEFUN INTEGERPFR (A) (IF (NOT (MAXIMA-INTEGERP A)) (INTEGERP1 A)))
-
- (DEFUN NONZERP (A) (NOT (EQUAL A 0)))
-
- (DEFUN FREEVNZ (A) (AND (FREEVAR A) (NOT (EQUAL A 0))))
-
- (DEFUN INTE (FUNCT X)
- (PROG (CHECKCOEFSIGNLIST GLOBALCAREFLAG $RADEXPAND)
- (SETQ $RADEXPAND T)
- (RETURN (INTIR-REF FUNCT X))))
-
- (DEFUN INTIR-REF (FUN X)
- (PROG (A)
- (COND ((SETQ A (INTIR1 FUN X))(RETURN A)))
- (COND ((SETQ A (INTIR2 FUN X))(RETURN A)))
- (RETURN (INTIR3 FUN X))))
-
- (DEFUN INTIR1 (FUN X)
- (PROG (ASSOCLIST E0 R0 E1 E2 R1 R2 D P)
- (SETQ ASSOCLIST (FACTPOW (SPECREPCHECK FUN) X))
- (SETQ E1 (CDRAS 'E1 ASSOCLIST) E2 (CDRAS 'E2 ASSOCLIST))
- (COND ((NULL ASSOCLIST)(RETURN NIL)))
- (SETQ D (CDRAS 'D ASSOCLIST) P (CDRAS 'P ASSOCLIST)
- E0 (CDRAS 'E0 ASSOCLIST) R0 (CDRAS 'R0 ASSOCLIST)
- R1 (CDRAS 'R1 ASSOCLIST) R2 (CDRAS 'R2 ASSOCLIST))
- (COND ((FLOATP E0)(SETQ E0 (RDIS (RATION1 E0)))))
- (COND ((FLOATP E1)(SETQ E1 (RDIS (RATION1 E1)))))
- (COND ((FLOATP E2)(SETQ E2 (RDIS (RATION1 E2)))))
- (RETURN (INTIR1-REF D P R0 E0 R1 E1 R2 E2 X))))
-
- (DEFUN INTIR2 (FUNCT X)
- (PROG (RES)
- (COND ((SETQ RES (INTIR FUNCT X))(RETURN RES)))
- (RETURN (INTIRFACTOROOT FUNCT X))))
-
- (DEFUN INTIR3 (EXP X)
- (PROG (ASSOCLIST E F G R0)
- (COND ((SETQ ASSOCLIST (ELLIPTQUAD EXP X))
- (SETQ E (CDRAS 'E ASSOCLIST) F (CDRAS 'F ASSOCLIST)
- G (CDRAS 'G ASSOCLIST) R0 (CDRAS 'R0 ASSOCLIST))
- (ASSUME `(($NOTEQUAL) ,E 0))
- (RETURN (INTIR3-R0TEST ASSOCLIST X E F G R0))))
- (RETURN NIL)))
-
- (DEFUN INTIR3-R0TEST (ASSOCLIST X E F G R0)
- (COND ((ROOT+ANYTHING R0 X) NIL)
- (T (INTIR3-REF ASSOCLIST X E F G R0))))
-
- (DEFUN INTIR1-REF (D P R0 E0 R1 E1 R2 E2 X)
- ((LAMBDA (NUME1 NUME2)
- (COND ((AND (PLUSP NUME1)(PLUSP NUME2))
- (PP-INTIR1 D P R0 E0 R1 E1 R2 E2 X))
- ((AND (MINUSP NUME1)(MINUSP NUME2))
- (MM-INTIR1 D P R0 E0 R1 E1 R2 E2 X))
- ((PLUSP NUME1)(PM-INTIR1 D P R0 E0 R1 E1 R2 E2 X))
- (T (PM-INTIR1 D P R0 E0 R2 E2 R1 E1 X))))
- (CADR E1) (CADR E2)))
-
- (DEFUN PP-INTIR1 (D P R0 E0 R1 E1 R2 E2 X)
- ((LAMBDA (NUME1 NUME2)
- (COND ((GREATERP NUME1 NUME2)(PP-INTIR1-EXEC D P R0 E0 R1 E1 R2 E2 X))
- (T (PP-INTIR1-EXEC D P R0 E0 R2 E2 R1 E1 X))))
- (CADR E1) (CADR E2)))
-
- (DEFUN MM-INTIR1 (D P R0 E0 R1 E1 R2 E2 X)
- ((LAMBDA (NUME1 NUME2)
- (COND ((GREATERP NUME1 NUME2)(MM-INTIR1-EXEC D P R0 E0 R1 E1 R2 E2 X))
- (T (MM-INTIR1-EXEC D P R0 E0 R2 E2 R1 E1 X))))
- (CADR E1) (CADR E2)))
-
- (DEFUN PM-INTIR1 (D P R0 E0 ROFPOS EPOS ROFNEG ENEG X)
- ((LAMBDA (NUMEPOS NUMUL-1ENEG)
- (COND ((GREATERP NUMEPOS NUMUL-1ENEG)
- (MM-INTIR1 D (MUL P (POWER ROFPOS (SUB EPOS ENEG)))
- R0 E0 ROFPOS ENEG ROFNEG ENEG X))
- ((OR (EQUAL E0 0) (PLUSP E0))
- (PP-INTIR1 D (MUL P (POWER ROFNEG (SUB ENEG EPOS)))
- R0 E0 ROFPOS EPOS ROFNEG EPOS X))
- (T (MM-INTIR1 D (MUL P (POWER ROFPOS (SUB EPOS ENEG)))
- R0 E0 ROFPOS ENEG ROFNEG ENEG X))))
- (CADR EPOS)
- (MUL -1 (CADR ENEG))))
-
- (DEFUN PP-INTIR1-EXEC (D P R0 E0 ROFMAX EMAX ROFMIN EMIN X)
- (INTIR (MUL D P (COND ((EQUAL E0 0) 1) (T (POWER R0 E0)))
- (POWER ROFMAX (ADD EMAX (MUL -1 EMIN)))
- (POWER ($EXPAND (MUL ROFMAX ROFMIN)) EMIN)) X))
-
- (DEFUN MM-INTIR1-EXEC (D P R0 E0 ROFMIN EMIN ROFMAX EMAX X)
- (INTIR (MUL D P (COND ((EQUAL E0 0) 1) (T (POWER R0 E0)))
- (POWER ROFMAX (ADD EMAX (MUL -1 EMIN)))
- (POWER ($EXPAND (MUL ROFMAX ROFMIN)) EMIN)) X))
-
- (DEFUN INTIR3-REF (ASSOCLIST X E F G R0)
- ((LAMBDA (SIGNDISC D P E0)
- (COND ((OR (EQ SIGNDISC '$POSITIVE)(EQ SIGNDISC '$NEGATIVE))
- (PNS-INTIR3 X E F G D P R0 E0))
- (T (ZS-INTIR3 X E F D P R0 E0))))
- (SIGNDISCR E F G)
- (CDRAS 'D ASSOCLIST)
- (CDRAS 'P ASSOCLIST)
- (CDRAS 'E0 ASSOCLIST)))
-
- (DEFUN ROOT+ANYTHING (EXP VAR)
- (M2 EXP '((MPLUS) ((COEFFPT) (C NONZERP) ((MEXPT) (U HASVAR) (V INTEGERPFR)))
- ((COEFFPP)(C TRUE))) NIL))
-
- (DEFUN PNS-INTIR3 (X E F G D P R0 E0)
- ((LAMBDA (DISCR)
- ((LAMBDA (P*R0^E0 2*E*X+F 2*E*D*INVDISC)
- (MUL (SUB (INTIR2 (MUL 2*E*D*INVDISC
- (INV (SUB 2*E*X+F DISCR))
- P*R0^E0)
- X)
- (INTIR2 (MUL 2*E*D*INVDISC
- (INV (ADD 2*E*X+F DISCR))
- P*R0^E0)
- X))))
- (MUL P (POWER R0 E0))
- (ADD (MUL 2 E X) F)
- (MUL 2 E D (INV DISCR))))
- (POWER (SUB (MUL F F)(MUL 4 E G)) (INV 2))))
-
- (DEFUN ZS-INTIR3 (X E F D P R0 E0)
- (INTIR2 (MUL D P E
- (POWER (ADD X (DIV F (ADD E E))) -2) (POWER R0 E0))
- X))
-
- (DEFUN CDRAS (A B)
- (CDR (zl-ASSOC A B)))
-
- (DEFUN INTIR (FUNCT X)
- (PROG (ASSOCLIST)
- (SETQ ASSOCLIST (JMAUG (SPECREPCHECK FUNCT) X))
- (RETURN (INTI FUNCT X ASSOCLIST))))
-
- (DEFUN INTI (FUNCT X ASSOCLIST)
- (PROG (MET N EXPR F E DENOM)
- (SETQ N (CDRAS 'N ASSOCLIST))
- (COND ((OR (NULL ASSOCLIST) (MAXIMA-INTEGERP N))
- (RETURN NIL)))
- (SETQ F (CDRAS 'F ASSOCLIST) E (CDRAS 'E ASSOCLIST))
- (COND ((OR (EQUAL E 0) (NULL E))
- (RETURN (INTIRA FUNCT X))))
- (COND ((NOT (NUMBERP F)) (GO JUMP)))
- (COND ((PLUSP F)(GO JUMP)))
- (SETQ DENOM (ADD (MUL F X) E) F (MUL -1 F) E (MUL -1 E)
- FUNCT (MUL -1 (DIV (MEVAL (MUL DENOM FUNCT))(ADD (MUL F X) E))))
- JUMP (SETQ EXPR
- (MUL (POWER F -1)
- (INTIRA (DISTREXPANDROOT
- (CDR ($SUBSTITUTE
- (MUL (POWER F -1)
- (ADD (SETQ MET
- (MAKE-SYMBOL
- "YANNIS")
- )
- (MUL -1 E)))
- X FUNCT)))
- MET)))
- (RETURN ($EXPAND ($SUBSTITUTE (ADD (MUL F X) E) MET EXPR)))))
-
- (DEFUN DISTREXPANDROOT (EXPR)
- (COND ((NULL EXPR) 1)
- (T (MUL (EXPANDROOT (CAR EXPR))
- (DISTREXPANDROOT (CDR EXPR))))))
-
- (DEFUN EXPANDROOT (EXPR)
- (COND ((ATOM EXPR) EXPR)
- (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT)
- (INTEGERPFR (CADDR EXPR)))
- ($EXPAND EXPR))
- (T EXPR)))))
-
- (DEFUN INTIRFACTOROOT (EXPR X)
- (PROG (ASSOCLIST EXP)
- (SETQ EXP EXPR)
- (COND ((SETQ ASSOCLIST (JMAUG (SETQ EXPR (DISTRFACTOR (TIMESTEST EXPR) X)) X))
- (RETURN (INTI EXPR X ASSOCLIST))))
- (SETQ GLOBALCAREFLAG 'T)
- (COND ((SETQ ASSOCLIST (JMAUG (SETQ EXP (DISTRFACTOR (TIMESTEST EXP) X)) X))
- (SETQ GLOBALCAREFLAG NIL)
- (RETURN (INTI EXP X ASSOCLIST))))
- (SETQ GLOBALCAREFLAG NIL)
- (RETURN NIL)))
-
- (DEFUN DISTRFACTOR (EXPR X)
- (COND ((NULL EXPR) 1)
- (T (MUL (FACTOROOT (CAR EXPR) X)
- (DISTRFACTOR (CDR EXPR) X)))))
-
- (DEFUN FACTOROOT (EXPR VAR)
- (COND ((ATOM EXPR) EXPR)
- (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT)
- (HASVAR EXPR)
- (INTEGERPFR (CADDR EXPR)))
- (CAREFULFACTOR EXPR VAR))
- (T EXPR)))))
-
- (DEFUN CAREFULFACTOR (EXPR X)
- (COND ((NULL GLOBALCAREFLAG)($FACTOR EXPR))
- (T (RESTOREX ($FACTOR (POWER (DIV (CADR EXPR) X) (CADDR EXPR))) X))))
-
- (DEFUN RESTOREX (EXPR VAR)
- (COND ((ATOM EXPR) EXPR)
- (T (COND ((EQ (CAAR EXPR) 'MTIMES)
- (DISTRESTOREX (CDR EXPR) VAR))
- (T EXPR)))))
-
- (DEFUN DISTRESTOREX (EXPR VAR)
- (COND ((NULL EXPR) 1)
- (T (MUL (RESTOROOT (CAR EXPR) VAR)
- (DISTRESTOREX (CDR EXPR) VAR)))))
-
- (DEFUN RESTOROOT (EXPR VAR)
- (COND ((ATOM EXPR) EXPR)
- (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT)
- (INTEGERPFR (CADDR EXPR))
- (MPLUSP (CADR EXPR)))
- (POWER ($EXPAND (MUL VAR (CADR EXPR))) (CADDR EXPR)))
- (T EXPR)))))
-
- (DEFUN TIMESTEST (EXPR)
- (COND ((ATOM EXPR)(LIST EXPR))
- (T (COND ((EQ (CAAR EXPR) 'MTIMES)(CDR EXPR))
- (T (LIST EXPR))))))
-
- (DEFUN INTIRA (FUNCT X)
- (PROG (A B C EC-1 D M N ASSOCLIST PLUSPOWFO1 PLUSPOWFO2 MINUSPOWFO
- POLFACT SIGNN POSZPOWLIST NEGPOWLIST R12)
- (SETQ ASSOCLIST (JMAUG (SPECREPCHECK FUNCT) X))
- (SETQ N (CDRAS 'N ASSOCLIST) R12 1//2)
- (COND ((OR (NULL ASSOCLIST) (MAXIMA-INTEGERP N))(RETURN NIL)))
- (COND ((FLOATP N)(SETQ N (RDIS (RATION1 N)))))
- (SETQ D (CDRAS 'D ASSOCLIST))
- (COND ((EQUAL D 0) (RETURN 0)))
- (SETQ C (CDRAS 'A ASSOCLIST))
- (IF (EQUAL C 0) (RETURN NIL))
- (SETQ M (CDRAS 'M ASSOCLIST) POLFACT (CDRAS 'P ASSOCLIST) N (CADR N)
- SIGNN (CHECKSIGNTM N) EC-1 (POWER C -1)
- B (CDRAS 'B ASSOCLIST) A (CDRAS 'C ASSOCLIST)
- PLUSPOWFO1 (MUL R12 (PLUS N -1))
- MINUSPOWFO (MUL R12 (PLUS N 1))
- PLUSPOWFO2 (TIMES -1 MINUSPOWFO)
- POSZPOWLIST (CAR (POWERCOEFLIST POLFACT M X))
- NEGPOWLIST (CADR (POWERCOEFLIST POLFACT M X)))
- (COND ((AND (NULL NEGPOWLIST)(NOT (NULL POSZPOWLIST)))
- (COND ((EQ SIGNN '$POSITIVE)
- (RETURN (AUGMULT (MUL D
- (NUMMNUMN POSZPOWLIST
- PLUSPOWFO1
- MINUSPOWFO C B A X))))))
- (RETURN (AUGMULT (MUL D
- (NUMMDENN POSZPOWLIST
- PLUSPOWFO2 C B A X))))))
- (COND ((AND (NULL POSZPOWLIST)(NOT (NULL NEGPOWLIST)))
- (COND ((EQ SIGNN '$POSITIVE)
- (RETURN (AUGMULT (MUL D
- (DENMNUMN NEGPOWLIST
- MINUSPOWFO C B A X))))))
- (RETURN (AUGMULT (MUL D
- (DENMDENN NEGPOWLIST
- PLUSPOWFO2 C B A X))))))
- (COND ((AND (NOT (NULL NEGPOWLIST)) (NOT (NULL POSZPOWLIST)))
- (COND ((EQ SIGNN '$POSITIVE)
- (RETURN (ADD (AUGMULT (MUL D
- (NUMMNUMN POSZPOWLIST
- PLUSPOWFO1
- MINUSPOWFO C B A X)))
- (AUGMULT (MUL D
- (DENMNUMN NEGPOWLIST
- MINUSPOWFO C B A X)))))))
- (RETURN (ADD (AUGMULT (MUL D
- (NUMMDENN POSZPOWLIST
- PLUSPOWFO2 C B A X)))
- (AUGMULT (MUL D
- (DENMDENN NEGPOWLIST
- PLUSPOWFO2 C B A X)))))))))
-
- (DEFUN JMAUG (EXP VAR)
- (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR))
- ((COEFFTT)(P POLYP))
- ((MEXPT) ((MPLUS) ((COEFFPT)(F FREEVAR)(X VARP))
- ((COEFFPP)(E FREEVAR)))
- (M MAXIMA-INTEGERP))
- ((MEXPT) ((MPLUS) ((COEFFPT) (A FREEVAR) ((MEXPT) (X VARP) 2))
- ((COEFFPT) (B FREEVAR)(X VARP))
- ((COEFFPP) (C FREEVAR)))
- (N INTEGERP1)))
- NIL))
-
- (DEFUN FACTPOW (EXP VAR)
- (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR))
- ((COEFFTT) (P POLYP))
- ((MEXPT) (R1 HASVAR)
- (E1 INTEGERPFR))
- ((MEXPT) (R2 HASVAR)
- (E2 INTEGERPFR))
- ((MEXPT) (R0 HASVAR)
- (E0 MAXIMA-INTEGERP)))
- NIL))
-
- (DEFUN ELLIPTQUAD (EXP VAR)
- (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR))
- ((COEFFTT) (P POLYP))
- ((MEXPT) ((MPLUS) ((COEFFPT) (E FREEVNZ) ((MEXPT) (X VARP) 2))
- ((COEFFPT) (F FREEVAR) (X VARP))
- ((COEFFPP) (G FREEVAR)))
- -1)
- ((MEXPT) (R0 HASVAR)
- (E0 INTEGERPFR)))
- NIL))
-
- (DEFUN POLFOO (C B A X)
- (ADD (MUL C X X)
- (MUL B X)
- A))
-
- (DEFUN POWERCOEFLIST (FUN M VAR)
- (PROG (EXPANFUN MAXPOWFUN POWFUN COEF POSZPOWLIST NEGPOWLIST)
- (SETQ EXPANFUN (UNQUOTE ($EXPAND (MUL (PREVCONSTEXPAN FUN VAR)
- (POWER VAR M)))))
- (COND ((AND (EQUAL FUN 1) (GREATERP M 0))
- (RETURN (CONS NIL (LIST (LIST (CONS M (LIST 1))))))))
- (COND ((AND (EQUAL FUN 1)(LESSP M 0))
- (RETURN (CONS NIL (LIST (LIST (CONS (TIMES -1 M ) (LIST 1))))))))
- (COND ((EQUAL EXPANFUN 1)
- (RETURN (CONS (LIST (CONS 0 (LIST 1)))
- (LIST NIL)))))
- (SETQ MAXPOWFUN ($HIPOW EXPANFUN VAR)
- POWFUN ($LOPOW EXPANFUN VAR))
- LOOP (SETQ COEF ($COEFF EXPANFUN (POWER VAR POWFUN)))
- (COND ((NUMBERP COEF) (GO TESTJUMP)))
- (GO NOJUMP)
- TESTJUMP (COND ((AND (NOT (ZEROP POWFUN)) (ZEROP COEF))
- (GO JUMP)))
- NOJUMP (COND ((GREATERP POWFUN 0)
- (SETQ POSZPOWLIST (APPEND POSZPOWLIST
- (LIST (CONS POWFUN (LIST COEF)))))))
- (COND ((ZEROP POWFUN)
- (SETQ POSZPOWLIST
- (APPEND POSZPOWLIST
- (LIST (CONS 0 (LIST (CONSTERM (CDR EXPANFUN) VAR))))))))
- (COND ((LESSP POWFUN 0)
- (SETQ NEGPOWLIST (APPEND NEGPOWLIST
- (LIST (CONS (TIMES -1 POWFUN)(LIST COEF)))))))
- (COND ((EQUAL POWFUN MAXPOWFUN)
- (RETURN (LIST POSZPOWLIST (REVERSE NEGPOWLIST)))))
- JUMP (SETQ POWFUN (ADD1 POWFUN)) (GO LOOP)))
-
- (DEFUN CONSTERM (FUN VAR)
- (COND ((NULL FUN) 0)
- ((FREEOF VAR (CAR FUN))
- (ADD (CAR FUN) (CONSTERM (CDR FUN) VAR)))
- (T (CONSTERM (CDR FUN) VAR))))
-
- (DEFUN PREVCONSTEXPAN (FUN VAR)
- (COND ((ATOM FUN) FUN)
- ((EQ (CAAR FUN) 'MPLUS)
- (COND ((AND (FREEOF VAR FUN)
- (NOT (INSIDE FUN 'MEXPT)))
- (LIST '(MQUOTE) FUN))
- ((AND (FREEOF VAR FUN) (INSIDE FUN 'MEXPT))
- (LIST '(MQUOTE)
- (DISTRINPLUSPREV (CDR FUN) VAR)))
- ((INSIDE FUN 'MEXPT)
- (DISTRINPLUSPREV (CDR FUN) VAR))
- (T FUN)))
- ((EQ (CAAR FUN) 'MTIMES)
- (DISTRINTIMESPREV (CDR FUN) VAR))
- ((AND (NOT (INSIDE (CDR FUN) VAR))
- (EQ (CAAR FUN) 'MEXPT))
- (POWER (PREVCONSTEXPAN (CADR FUN) VAR) (CADDR FUN)))
- (T FUN)))
-
- (DEFUN DISTRINPLUSPREV (FUN VAR)
- (COND ((NULL FUN) 0)
- (T (ADD (PREVCONSTEXPAN (CAR FUN) VAR)
- (DISTRINPLUSPREV (CDR FUN) VAR)))))
-
- (DEFUN DISTRINTIMESPREV (FUN VAR)
- (COND ((NULL FUN) 1)
- (T (MUL (PREVCONSTEXPAN (CAR FUN) VAR)
- (DISTRINTIMESPREV (CDR FUN) VAR)))))
-
- (DEFUN INSIDE (FUN ARG)
- (COND ((ATOM FUN)(EQUAL FUN ARG))
- ((INSIDE (CAR FUN) ARG) T)
- (T (INSIDE (CDR FUN) ARG))))
-
- (DEFUN UNQUOTE (FUN)
- (COND ((NOT (INSIDE FUN 'MQUOTE)) FUN)
- (T (UNQUOTE (MEVAL FUN)))))
-
- (DEFUN CHECKSIGNTM (EXPR)
- (PROG (ASLIST QUEST ZEROSIGNTEST PRODUCTCASE)
- (SETQ ASLIST CHECKCOEFSIGNLIST)
- (COND ((ATOM EXPR) (GO LOOP)))
- (COND ((EQ (CAAR EXPR) 'MTIMES)(SETQ PRODUCTCASE T)))
- LOOP (COND ((NULL ASLIST)
- (SETQ CHECKCOEFSIGNLIST
- (APPEND CHECKCOEFSIGNLIST
- (LIST (CONS EXPR
- (LIST
- (SETQ QUEST (CHECKFLAGANDACT EXPR)))))))
- (RETURN QUEST)))
- (COND ((EQUAL (CAAR ASLIST) EXPR) (RETURN (CADAR ASLIST))))
- (SETQ ASLIST (CDR ASLIST))
- (GO LOOP)))
-
- (DEFUN CHECKFLAGANDACT (EXPR)
- (COND (PRODUCTCASE
- (SETQ PRODUCTCASE NIL)
- (FINDSIGNOFTHEIRPRODUCT (FINDSIGNOFACTORS (CDR EXPR))))
- (T (ASKSIGN ($REALPART EXPR)))))
-
- (DEFUN FINDSIGNOFACTORS (LISTOFACTORS)
- (COND ((NULL LISTOFACTORS) NIL)
- ((EQ ZEROSIGNTEST '$ZERO) '$ZERO)
- (T (APPEND (LIST (SETQ ZEROSIGNTEST (CHECKSIGNTM (CAR LISTOFACTORS))))
- (FINDSIGNOFACTORS (CDR LISTOFACTORS))))))
-
- (DEFUN FINDSIGNOFTHEIRPRODUCT (LLIST)
- (PROG (SIGN)
- (COND ((EQ LLIST '$ZERO) (RETURN '$ZERO)))
- (SETQ SIGN '$POSITIVE)
- LOOP (COND ((NULL LLIST) (RETURN SIGN)))
- (COND ((EQ (CAR LLIST) '$POSITIVE)
- (SETQ LLIST (CDR LLIST))
- (GO LOOP)))
- (COND ((EQ (CAR LLIST) '$NEGATIVE)
- (SETQ SIGN (CHANGESIGN SIGN) LLIST (CDR LLIST))
- (GO LOOP)))
- (RETURN '$ZERO)))
-
- (DEFUN CHANGESIGN (SIGN)
- (COND ((EQ SIGN '$POSITIVE) '$NEGATIVE)
- (T '$POSITIVE)))
-
- (DEFUN DEN1 (C B A X)
- ((LAMBDA (EXPO EXPR)
- (PROG (SIGNDISCRIM SIGNC SIGNB)
- (SETQ SIGNC (CHECKSIGNTM (POWER C -1)))
- (SETQ SIGNB (CHECKSIGNTM (POWER B 2)))
- (SETQ SIGNDISCRIM (SIGNDIS2 C B A SIGNC SIGNB))
- (COND ((AND (EQ SIGNC '$POSITIVE)
- (EQ SIGNDISCRIM '$NEGATIVE))
- (RETURN (AUGMULT (MUL* (POWER C EXPO)
- (LIST '(%ASINH)
- (MUL EXPR
- (POWER (ADD (MUL 4 C A)
- (MUL -1 B B))
- EXPO))))))))
- (COND ((AND (EQ SIGNC '$POSITIVE)
- (EQ SIGNDISCRIM '$ZERO))
- (RETURN (AUGMULT (MUL* (POWER -1 EXPR)
- (POWER C EXPO)
- (LIST '(%LOG) EXPR))))))
- (COND ((EQ SIGNC '$POSITIVE)
- (RETURN (AUGMULT (MUL* (POWER C EXPO)
- (LIST '(%LOG)
- (ADD (MUL 2
- (POWER C R12)
- (POWER
- (POLFOO C B
- A X)
- R12))
- EXPR)))))))
- (COND ((AND (EQ SIGNC '$NEGATIVE)
- (EQ SIGNDISCRIM '$POSITIVE))
- (RETURN (AUGMULT (MUL* -1
- (POWER (MUL -1 C) EXPO)
- (LIST '(%ASIN)
- (MUL EXPR
- (POWER (ADD (MUL B B)
- (MUL -4 C A))
- EXPO))))))))
- (COND ((EQ SIGNC '$NEGATIVE)
- (RETURN (AUGMULT (MUL (POWER -1 EXPO)
- (DEN1 (MUL -1 C)
- (MUL -1 B)
- (MUL -1 A)
- X))))))))
- (LIST '(RAT) -1 2) (ADD (MUL 2 C X) B)))
-
- (DEFUN SIGNDISCR (C B A)
- (CHECKSIGNTM (SIMPLIFYA (ADD (POWER B 2)
- (MUL -4 C A))
- NIL)))
-
- (DEFUN ASKINVER (A)
- (CHECKSIGNTM (POWER A -1)))
-
- (DEFUN SIGNDIS1 (C B A)
- (COND ((EQUAL (MUL B A) 0)
- (COND ((AND (EQUAL B 0)(EQUAL A 0)) '$ZERO)
- (T '$NONZERO)))
- (T (CHECKSIGNTM (POWER (ADD (MUL B B) (MUL -4 C A)) 2)))))
-
- (DEFUN SIGNDIS2 (C B A SIGNC SIGNB)
- (COND ((EQUAL SIGNB '$ZERO)
- (COND ((EQUAL A 0) '$ZERO)
- (T ((LAMBDA (ASKINV)
- (COND ((OR (AND (EQ SIGNC '$POSITIVE)
- (EQ ASKINV '$NEGATIVE))
- (AND (EQ SIGNC '$NEGATIVE)
- (EQ ASKINV '$POSITIVE)))
- '$POSITIVE)
- (T '$NEGATIVE)))
- (ASKINVER A)))))
- (T (COND ((EQUAL A 0) '$POSITIVE)
- (T (SIGNDISCR C B A))))))
-
- (DEFUN SIGNDIS3 (C B A SIGNA)
- (COND ((EQUAL B 0)
- (COND ((EQUAL (CHECKSIGNTM EC-1) SIGNA) '$NEGATIVE)
- (T '$POSITIVE)))
- (T (SIGNDISCR C B A))))
-
- (DEFUN NUMMNUMN (POSZPOWLIST PLUSPOWFO1 P C B A X)
- ((LAMBDA (EXPR EXPO EX)
- (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES)
- (SETQ RESULT 0 CONTROLPOW (CAAR POSZPOWLIST)
- COEF (CADAR POSZPOWLIST))
- (COND ((ZEROP CONTROLPOW)
- (SETQ RESULT (AUGMULT (MUL COEF (NUMN PLUSPOWFO1 C B A X)))
- COUNT 1)
- (GO LOOP)))
- JUMP1 (SETQ RES1 (ADD (AUGMULT (MUL EXPR EXPO
- (POWER (PLUS P P 1) -1)))
- (AUGMULT (MUL -1 B R12 EXPO
- (NUMN PLUSPOWFO1 C B A X)))))
- (COND ((EQUAL CONTROLPOW 1)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1)))
- COUNT 2)
- (GO LOOP)))
- JUMP2 (SETQ RES2 (ADD (AUGMULT (MUL* X EXPR EXPO
- (INV (PLUS P P 2))))
- (AUGMULT (MUL* B (PLUS P P 3)
- (LIST '(RAT) -1 4)
- EX
- (INV (PLUS P P P 1
- (TIMES P P)
- (TIMES P P)))
- EXPR))
- (AUGMULT (MUL (INV (PLUS P 1))
- EX
- (LIST '(RAT) 1 8.)
- (ADD (MUL (POWER B 2)
- (PLUS P P 3))
- (MUL -4 A C))
- (NUMN PLUSPOWFO1 C B A X)))))
- (COND ((EQUAL CONTROLPOW 2)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2)))
- COUNT 3)
- (GO LOOP)))
- JUMP3 (SETQ COUNT 4 M 3)
- JUMP (SETQ PARTRES
- ((LAMBDA (PRO)
- (ADD (AUGMULT (MUL (POWER X (PLUS M -1))
- EXPR EXPO PRO))
- (AUGMULT (MUL -1 B (PLUS P P M M -1)
- R12 EXPO PRO RES2))
- (AUGMULT (MUL -1 A (PLUS M -1)
- EXPO PRO RES1))))
- (POWER (PLUS M P P) -1)))
- (SETQ M (PLUS M 1))
- (COND ((GREATERP M CONTROLPOW)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES))))
- (GO LOOP)))
- JUMP4 (SETQ RES1 RES2 RES2 PARTRES)
- (GO JUMP)
- LOOP (SETQ POSZPOWLIST (CDR POSZPOWLIST))
- (COND ((NULL POSZPOWLIST) (RETURN RESULT)))
- (SETQ COEF (CADAR POSZPOWLIST))
- (SETQ CONTROLPOW (CAAR POSZPOWLIST))
- (COND ((EQUAL COUNT 4) (GO JUMP4)))
- (COND ((EQUAL COUNT 1) (GO JUMP1)))
- (COND ((EQUAL COUNT 2) (GO JUMP2)))
- (GO JUMP3)))
- (POWER (POLFOO C B A X) (ADD P R12)) EC-1 (POWER C -2)))
-
- (DEFUN NUMN (P C B A X)
- ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5)
- (COND ((ZEROP P) (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) EXP1
- EXP2 (POWER (POLFOO C B A X) EXP3)))
- (AUGMULT (MUL (LIST '(RAT) 1 8) EXP1 EXP4
- (DEN1 C B A X)))))
- (T (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) EXP1 EXP5 EXP2
- (POWER (POLFOO C B A X) (ADD P EXP3))))
- (AUGMULT (MUL (LIST '(RAT) 1 8) EXP1 EXP5 (PLUS P P 1)
- EXP4 (NUMN (PLUS P -1) C B A X)))))))
- EC-1 (ADD B (MUL 2 C X)) R12
- (ADD (MUL 4 A C) (MUL -1 B B)) (LIST '(RAT) 1 (PLUS P 1))))
-
- (DEFUN AUGMULT (X)
- ($MULTTHRU (SIMPLIFYA X NIL)))
-
- (DEFUN DENMDENN (NEGPOWLIST P C B A X)
- ((LAMBDA (EXP1)
- (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES SIGNA EA-1)
- (SETQ SIGNA (CHECKSIGNTM (SIMPLIFYA A NIL)))
- (COND ((EQ SIGNA '$ZERO)
- (RETURN (NOCONSTQUAD NEGPOWLIST P C B X))))
- (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) EA-1 (POWER A -1))
- (SETQ COEF (CADAR NEGPOWLIST))
- (COND ((ZEROP CONTROLPOW)
- (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B A X)))
- COUNT 1)
- (GO LOOP)))
- JUMP1 (SETQ RES1 (DEN1DENN P C B A X))
- (COND ((EQUAL CONTROLPOW 1)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1)))
- COUNT 2)
- (GO LOOP)))
- JUMP2 (SETQ RES2 (ADD (AUGMULT (MUL -1 EA-1 (POWER X -1) EXP1))
- (AUGMULT (MUL -1 B (PLUS 1 P P) R12
- EA-1 (DEN1DENN P C B A X)))
- (AUGMULT (MUL -2 P C EA-1 (DENN P C B A X)))))
- (COND ((EQUAL CONTROLPOW 2)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2)))
- COUNT 3)
- (GO LOOP)))
- JUMP3 (SETQ COUNT 4 M 3)
- JUMP (SETQ PARTRES
- ((LAMBDA (EXP2)
- (ADD (AUGMULT (MUL EXP2 EA-1
- (POWER X (PLUS 1 (TIMES -1 M)))
- EXP1))
- (AUGMULT (MUL B (PLUS P P M M -3) R12
- EA-1 EXP2 RES2))
- (AUGMULT (MUL C EA-1 EXP2
- (PLUS P P M -2) RES1))))
- (SIMPLIFYA (LIST '(RAT) -1 (PLUS M -1)) NIL)))
- (SETQ M (PLUS M 1))
- (COND ((GREATERP M CONTROLPOW)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES))))
- (GO LOOP)))
- JUMP4 (SETQ RES1 RES2 RES2 PARTRES)
- (GO JUMP)
- LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST))
- (COND ((NULL NEGPOWLIST) (RETURN RESULT)))
- (SETQ COEF (CADAR NEGPOWLIST)
- CONTROLPOW (CAAR NEGPOWLIST))
- (COND ((EQUAL COUNT 4) (GO JUMP4)))
- (COND ((EQUAL COUNT 1) (GO JUMP1)))
- (COND ((EQUAL COUNT 2) (GO JUMP2)))
- (GO JUMP3)))
- (POWER (POLFOO C B A X) (ADD R12 (TIMES -1 P)))))
-
- (DEFUN DENN (P C B A X)
- ((LAMBDA (SIGNDISC EXP1 EXP2 EXP3)
- (COND ((AND (EQ SIGNDISC '$ZERO)(ZEROP P))
- (AUGMULT (MUL* EC-1
- (LIST '(%LOG) (ADD X (MUL B R12 EC-1 ))))))
- ((AND (EQ SIGNDISC '$ZERO)(GREATERP P 0))
- (AUGMULT (MUL* (LIST '(RAT) -1 (PLUS P P))
- (POWER C (MUL (LIST '(RAT) -1 2)
- (PLUS P P 1)))
- (POWER (ADD X (MUL B R12 EC-1 ))
- (TIMES -2 P)))))
- ((ZEROP P) (DEN1 C B A X))
- ((EQUAL P 1)
- (AUGMULT (MUL 2 EXP1 EXP2 (POWER (POLFOO C B A X)
- (LIST '(RAT) -1 2)))))
- (T (ADD (AUGMULT (MUL 2 EXP1 EXP3 EXP2
- (POWER (POLFOO C B A X)
- (ADD R12 (TIMES -1 P)))))
- (AUGMULT (MUL 8 C (PLUS P -1) EXP3 EXP2
- (DENN (PLUS P -1) C B A X)))))))
- (SIGNDIS1 C B A) (ADD B (MUL 2 C X))
- (POWER (ADD (MUL 4 A C)(MUL B B -1)) -1) (INV (PLUS P P -1))))
-
- (DEFUN DEN1DENN (P C B A X)
- ((LAMBDA (SIGNA EA-1)
- (COND ((EQ SIGNA '$ZERO)(NOCONSTQUAD 1 P C B X))
- ((ZEROP P) (DEN1DEN1 C B A X))
- (T (ADD (AUGMULT (MUL (INV (PLUS P P -1)) EA-1
- (POWER (POLFOO C B A X)
- (ADD R12 (TIMES -1 P)))))
- (AUGMULT (MUL EA-1 (DEN1DENN (PLUS P -1) C B A X)))
- (AUGMULT (MUL -1 R12 EA-1 B (DENN P C B A X)))))))
- (CHECKSIGNTM (POWER A 2))
- (POWER A -1)))
-
- (DEFUN DEN1DEN1 (C B A X)
- ((LAMBDA (EXP2 EXP3 EXP4)
- (PROG (SIGNDISCRIM CONDITION SIGNA EXP1)
- (SETQ SIGNA (CHECKSIGNTM (SIMPLIFYA A NIL)))
- (SETQ CONDITION (ADD (MUL B X) A A))
- (COND ((EQ SIGNA '$ZERO)
- (RETURN (NOCONSTQUAD '((1 1)) 0 C B X))))
- (SETQ SIGNDISCRIM (SIGNDIS3 C B A SIGNA)
- EXP1 (POWER A (INV -2)))
- (COND ((AND (EQ SIGNA '$POSITIVE)
- (EQ SIGNDISCRIM '$NEGATIVE))
- (RETURN (MUL* -1 EXP1
- (LIST '(%ASINH)
- (AUGMULT (MUL EXP2 EXP3
- (POWER (ADD (MUL 4 A C)
- (MUL -1 B B))
- EXP4))))))))
- (COND ((AND (EQ SIGNDISCRIM '$ZERO)
- (EQ SIGNA '$POSITIVE))
- (RETURN (MUL* (POWER -1 CONDITION) -1 EXP1
- (LIST '(%LOG)
- (AUGMULT (MUL EXP3 EXP2)))))))
- (COND ((EQ SIGNA '$POSITIVE)
- (RETURN (MUL* -1 EXP1
- (LIST '(%LOG)
- (ADD B (MUL 2 A EXP3)
- (MUL 2 EXP3
- (POWER A R12)
- (POWER (POLFOO C B A X)
- R12))))))))
- (COND ((AND (EQ SIGNA '$NEGATIVE)
- (EQ SIGNDISCRIM '$POSITIVE))
- (RETURN (MUL* (POWER (MUL -1 A) EXP4)
- (LIST '(%ASIN)
- (AUGMULT (MUL EXP2 EXP3
- (POWER (ADD (MUL B B)
- (MUL -4 A C))
- EXP4))))))))
- (RETURN (MUL -1 (POWER -1 R12)
- (DEN1DEN1 (MUL -1 C) (MUL -1 B) (MUL -1 A) X)))))
- (ADD (MUL B X) A A) (POWER (LIST '(MABS) X) -1) (LIST '(RAT) -1 2)))
-
- (DEFUN NOCONSTQUAD (NEGPOWLIST P C B X)
- ((LAMBDA (EXP1 EXP2 EXP3)
- (PROG (RESULT CONTROLPOW COEF COUNT RES1 SIGNB M PARTRES EB-1)
- (SETQ SIGNB (CHECKSIGNTM (POWER B 2)))
- (COND ((EQ SIGNB '$ZERO)
- (RETURN (TRIVIAL1 NEGPOWLIST P C X))))
- (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST)
- COEF (CADAR NEGPOWLIST) EB-1 (INV B))
- (COND ((ZEROP CONTROLPOW)
- (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B 0 X)))
- COUNT 1)
- (GO LOOP)))
- JUMP1 (SETQ RES1 (ADD (AUGMULT (MUL -2 EXP1 EB-1 EXP2
- (POWER (POLFOO C B 0 X)
- (ADD R12 EXP3))))
- (AUGMULT (MUL -4 P C EXP1 EB-1 (DENN P C B 0 X)))))
- (COND ((EQUAL CONTROLPOW 1)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1)))
- COUNT 2)
- (GO LOOP)))
- JUMP2 (SETQ COUNT 3 M 2)
- JUMP (SETQ PARTRES (ADD (AUGMULT (MUL -2 (INV (PLUS P P M M -1))
- EB-1
- (POWER X (MUL -1 M))
- (POWER (POLFOO C B 0 X)
- (ADD R12 EXP3))))
- (AUGMULT (MUL -2 C (PLUS P P M -1)
- EB-1 (INV (PLUS P P M M -1)) RES1))))
- (SETQ M (PLUS M 1))
- (COND ((GREATERP M CONTROLPOW)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES))))
- (GO LOOP)))
- JUMP3 (SETQ RES1 PARTRES)
- (GO JUMP)
- LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST))
- (COND ((NULL NEGPOWLIST) (RETURN RESULT)))
- (SETQ COEF (CADAR NEGPOWLIST)
- CONTROLPOW (CAAR NEGPOWLIST))
- (COND ((EQUAL COUNT 3) (GO JUMP3)))
- (COND ((EQUAL COUNT 1) (GO JUMP1)))
- (GO JUMP2)))
- (INV (PLUS P P 1)) (POWER X -1) (TIMES -1 P)))
-
- (DEFUN TRIVIAL1 (NEGPOWLIST P C X)
- (COND ((NULL NEGPOWLIST) 0)
- (T (ADD (AUGMULT (MUL (POWER X
- (ADD (TIMES -2 P)
- (MUL -1
- (CAAR NEGPOWLIST))))
- (CADAR NEGPOWLIST)
- (POWER C
- (ADD (TIMES -1 P)
- (LIST '(RAT) -1 2)))
- (INV (ADD (TIMES -2 P)
- (MUL -1 (CAAR NEGPOWLIST))))))
- (TRIVIAL1 (CDR NEGPOWLIST) P C X)))))
-
- (DEFUN NUMMDENN (POSZPOWLIST P C B A X)
- ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5 EXP6 EXP7)
- (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES SIGNDISCRIM)
- (SETQ RESULT 0 CONTROLPOW (CAAR POSZPOWLIST))
- (SETQ COEF (CADAR POSZPOWLIST) SIGNDISCRIM (SIGNDIS1 C B A))
- (COND ((ZEROP CONTROLPOW)
- (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B A X)))
- COUNT 1)
- (GO LOOP)))
- JUMP1 (SETQ RES1
- (ADD (AUGMULT (MUL -1 EC-1 EXP1 EXP2))
- (AUGMULT (MUL B (LIST '(RAT) -1 2)
- EC-1 (DENN P C B A X)))))
- (COND ((EQUAL CONTROLPOW 1)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1)))
- COUNT 2)
- (GO LOOP)))
- JUMP2 (COND ((AND (GREATERP P 0)
- (NOT (EQ SIGNDISCRIM '$ZERO)))
- (SETQ RES2
- (ADD (AUGMULT (MUL EC-1 EXP1 EXP3 EXP2
- (ADD (MUL 2 A B)
- (MUL 2 B B X)
- (MUL -4 A C X))))
- (AUGMULT (MUL EC-1 EXP3 EXP1
- (ADD (MUL 4 A C)
- (MUL 2 B B P)
- (MUL -3 B B))
- (DENN (PLUS P -1)
- C B A X)))))))
- (COND ((AND (EQUAL P 0)
- (NOT (EQ SIGNDISCRIM '$ZERO)))
- (SETQ RES2
- (ADD (AUGMULT (MUL (LIST '(RAT) 1 4)
- EXP5
- (ADD (MUL 2 C X)
- (MUL -3 B))
- (POWER (POLFOO C B A X)
- R12)))
- (AUGMULT (MUL (LIST '(RAT) 1 8)
- EXP5
- (ADD (MUL 3 B B)
- (MUL -4 A C))
- (DEN1 C B A X)))))))
- (COND ((AND (EQUAL P 0)(EQ SIGNDISCRIM '$ZERO))
- (SETQ RES2
- (ADD (AUGMULT (MUL* B B (LIST '(RAT) 1 4)
- (POWER C -3)
- (LIST '(%LOG) EXP4)))
- (AUGMULT (MUL EC-1 R12 (POWER EXP4 2)))
- (AUGMULT (MUL -1 B X EXP5))))))
- (COND ((AND (EQUAL P 1) (EQ SIGNDISCRIM '$ZERO))
- (SETQ RES2
- (ADD (AUGMULT (MUL* EC-1 (LIST '(%LOG) EXP4)))
- (AUGMULT (MUL B EXP5 (POWER EXP4 -1)))
- (AUGMULT (MUL (LIST '(RAT) -1 8)
- (POWER C -3)
- B B (POWER EXP4 -2)))))))
- (COND ((AND (EQ SIGNDISCRIM '$ZERO)(GREATERP P 1))
- (SETQ RES2
- (ADD (AUGMULT (MUL EC-1 (POWER EXP4 EXP6)
- (INV EXP6)))
- (AUGMULT (MUL -1 B EXP5 (INV EXP7)
- (POWER EXP4 EXP7)))
- (AUGMULT (MUL B B (LIST '(RAT) -1 8)
- (POWER C -3)
- (INV P)
- (POWER EXP4
- (TIMES -2 P))))))))
- (COND ((EQUAL CONTROLPOW 2)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2)))
- COUNT 3)
- (GO LOOP)))
- JUMP3 (SETQ COUNT 4 M 3)
- JUMP (SETQ PARTRES
- ((LAMBDA (DENOM PM-1)
- (ADD (AUGMULT (MUL* (POWER X PM-1)
- EC-1 (LIST '(RAT) -1 DENOM)
- (POWER (POLFOO C B A X)
- (ADD R12
- (TIMES -1 P)))))
- (AUGMULT (MUL B (PLUS P P 1 (TIMES -2 M))
- (LIST '(RAT) -1 2)
- EC-1 (INV DENOM) RES2))
- (AUGMULT (MUL A PM-1 EC-1 (INV DENOM) RES1))))
- (PLUS P P (TIMES -1 M))
- (PLUS M -1)))
- ON (SETQ M (PLUS M 1))
- (COND ((GREATERP M CONTROLPOW)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES))))
- (GO LOOP)))
- JUMP4 (SETQ RES1 RES2 RES2 PARTRES)
- (COND ((EQUAL M (PLUS P P))
- (SETQ PARTRES
- ((LAMBDA (EXPR)
- (ADD (MUL X EXPR)
- (MUL -1 (DISTRINT (CDR ($EXPAND EXPR))
- X))))
- (NUMMDENN (LIST (LIST (PLUS M -1) 1))
- P C B A X)))
- (GO ON)))
- (GO JUMP)
- LOOP (SETQ POSZPOWLIST (CDR POSZPOWLIST))
- (COND ((NULL POSZPOWLIST) (RETURN RESULT)))
- (SETQ COEF (CADAR POSZPOWLIST) CONTROLPOW (CAAR POSZPOWLIST))
- (COND ((EQUAL COUNT 4) (GO JUMP4)))
- (COND ((EQUAL COUNT 1) (GO JUMP1)))
- (COND ((EQUAL COUNT 2) (GO JUMP2)))
- (GO JUMP3)))
- (INV (PLUS P P -1)) (POWER (POLFOO C B A X) (ADD R12 (TIMES -1 P)))
- (POWER (ADD (MUL 4 A C)(MUL -1 B B)) -1) (ADD X (MUL B R12 EC-1))
- (POWER C -2) (PLUS 2 (TIMES -2 P)) (PLUS 1 (TIMES -2 P))))
-
- (DEFUN DENMNUMN (NEGPOWLIST POW C B A X)
- ((LAMBDA (EXP1 EXP2)
- (PROG (RESULT CONTROLPOW P COEF COUNT RES1 RES2 M
- PARTRES SIGNA EA-1)
- (SETQ P (PLUS POW POW -1))
- (COND ((EQ (CAR NEGPOWLIST) 'T)
- (SETQ NEGPOWLIST (CDR NEGPOWLIST))
- (GO THERE)))
- (SETQ SIGNA (CHECKSIGNTM (POWER A 2)))
- (COND ((EQ SIGNA '$ZERO)
- (RETURN (NONCONSTQUADENUM NEGPOWLIST P C B X))))
- (SETQ EA-1 (INV A))
- THERE (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST)
- COEF (CADAR NEGPOWLIST))
- (COND ((ZEROP CONTROLPOW)
- (SETQ RESULT (AUGMULT (MUL COEF
- (NUMN (ADD (MUL P R12) R12)
- C B A X)))
- COUNT 1)
- (GO LOOP)))
- JUMP1 (SETQ RES1 (DEN1NUMN POW C B A X))
- (COND ((EQUAL CONTROLPOW 1)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1)))
- COUNT 2)
- (GO LOOP)))
- JUMP2 (COND ((NOT (EQUAL P 1))
- (SETQ RES2 (ADD (AUGMULT (MUL -1 EXP1
- (POWER (POLFOO C B A X)
- (ADD POW
- (LIST '(RAT) -1 2)))))
- (AUGMULT (MUL B (LIST '(RAT) EXP2 2)
- (DEN1NUMN (PLUS POW -1)
- C B A X)))
- (AUGMULT (MUL C EXP2 (NUMN (PLUS POW -2)
- C B A X)))))))
- (COND ((EQUAL P 1)
- (SETQ RES2 (ADD (AUGMULT (MUL -1 (POWER (POLFOO C B A X)
- R12)
- EXP1))
- (AUGMULT (MUL B R12 (DEN1DEN1 C B A X)))
- (AUGMULT (MUL C (DEN1 C B A X)))))))
- (COND ((EQUAL CONTROLPOW 2)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2)))
- COUNT 3)
- (GO LOOP)))
- JUMP3 (SETQ COUNT 4 M 3)
- JUMP (SETQ PARTRES
- ((LAMBDA (EXP3 EXP4)
- (ADD (AUGMULT (MUL* (LIST '(RAT) -1 EXP3)
- EA-1 (POWER X (PLUS 1 EXP4))
- (POWER (POLFOO C B A X)
- (ADD (LIST '(RAT) P 2)
- 1))))
- (AUGMULT (MUL (INV (PLUS M M -2))
- EA-1 B (PLUS P 4 (TIMES -2 M))
- RES2))
- (AUGMULT (MUL C EA-1 (PLUS P 3 EXP4)
- (INV EXP3) RES1))))
- (PLUS M -1) (TIMES -1 M))
- M (PLUS M 1))
- (COND ((GREATERP M CONTROLPOW)
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES))))
- (GO LOOP)))
- JUMP4 (SETQ RES1 RES2 RES2 PARTRES)
- (GO JUMP)
- LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST))
- (COND ((NULL NEGPOWLIST) (RETURN RESULT)))
- (SETQ COEF (CADAR NEGPOWLIST) CONTROLPOW (CAAR NEGPOWLIST))
- (COND ((EQUAL COUNT 4) (GO JUMP4)))
- (COND ((EQUAL COUNT 1) (GO JUMP1)))
- (COND ((EQUAL COUNT 2) (GO JUMP2)))
- (GO JUMP3)))
- (POWER X -1) (PLUS POW POW -1)))
-
- (DEFUN NONCONSTQUADENUM (NEGPOWLIST P C B X)
- (PROG (RESULT COEF M)
- (COND ((EQUAL P 1)(RETURN (CASE1 NEGPOWLIST C B X))))
- (SETQ RESULT 0)
- LOOP (SETQ M (CAAR NEGPOWLIST) COEF (CADAR NEGPOWLIST))
- (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF (CASEGEN M P C B X))))
- NEGPOWLIST (CDR NEGPOWLIST))
- (COND ((NULL NEGPOWLIST) (RETURN RESULT)))
- (GO LOOP)))
-
- (DEFUN CASEGEN (M P C B X)
- ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5)
- (COND ((EQUAL P 1) (CASE1 (LIST (LIST M 1)) C B X))
- ((ZEROP M) (CASE0 P C B X))
- ((EQUAL M (PLUS P 1))
- (ADD (AUGMULT (MUL -1 EXP1 (INV EXP2) EXP3))
- (AUGMULT (MUL B R12 (CASEGEN EXP2 EXP4 C B X)))
- (AUGMULT (MUL C (CASEGEN (PLUS M -2) EXP4 C B X)))))
- ((EQUAL M 1) (ADD (AUGMULT (MUL (INV P) EXP1))
- (AUGMULT (MUL B R12 (CASE0 EXP4 C B X)))))
- (T (ADD (AUGMULT (MUL -1 EXP1 (INV EXP5) EXP3))
- (AUGMULT (MUL -1 P B R12 (INV EXP5)
- (CASEGEN EXP2 EXP4 C B X)))))))
- (POWER (POLFOO C B 0 X)(LIST '(RAT) P 2))
- (PLUS M -1)
- (POWER X (PLUS 1 (TIMES -1 M)))
- (PLUS P -2)
- (PLUS M -1 (TIMES -1 P))))
-
- (DEFUN CASE1 (NEGPOWLIST C B X)
- ((LAMBDA (EXP1 EB-1)
- (PROG (RESULT CONTROLPOW M1 COEF COUNT RES1 RES2 M SIGNC
- SIGNB PARTRES RES)
- (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST)
- COEF (CADAR NEGPOWLIST) M1 (PLUS CONTROLPOW -2))
- (COND ((ZEROP CONTROLPOW)
- (SETQ RESULT (AUGMULT (MUL COEF (CASE0 1 C B X)))
- COUNT 1)
- (GO LOOP)))
- JUMP1 (COND ((EQUAL CONTROLPOW 1)
- (SETQ RESULT
- (ADD RESULT
- (AUGMULT (MUL COEF (DEN1NUMN 1 C B 0 X))))
- COUNT 2)
- (GO LOOP)))
- JUMP2 (COND ((EQUAL CONTROLPOW 2)
- (SETQ RESULT
- (ADD RESULT
- (AUGMULT (MUL COEF
- (DENMNUMN '(T (2 1))
- 1 C B 0 X))))
- COUNT 3)
- (GO LOOP)))
- JUMP3 (SETQ SIGNB (CHECKSIGNTM (POWER B 2)))
- (COND ((EQ SIGNB '$ZERO)(SETQ COUNT 5)(GO JUMP5)))
- (SETQ COUNT 4 M 0 SIGNC (CHECKSIGNTM EC-1))
- (COND ((EQ SIGNC '$POSITIVE)
- (SETQ RES
- (AUGMULT (MUL* 2 EXP1
- (LIST '(%LOG)
- (ADD (POWER (MUL C X)
- R12)
- (POWER (ADD B
- (MUL C X))
- R12))))))
- (GO JUMP4)))
- (SETQ RES
- (AUGMULT (MUL* 2 EXP1
- (LIST '(%ATAN)
- (POWER (MUL C X
- (POWER (ADD B
- (MUL -1 C X))
- -1))
- R12)))))
- JUMP4 (SETQ M (PLUS M 1)
- RES (ADD (AUGMULT (MUL -2 (POWER (POLFOO C B 0 X) R12)
- EB-1 (INV (PMM-1 M))
- (EXT-1M X M)))
- (AUGMULT (MUL* (LIST '(RAT) -2 (PMM-1 M))
- C (SUB1 M)
- EB-1 RES))))
- (COND ((EQUAL M M1) (SETQ RES2 RES) (GO JUMP4)))
- (COND ((EQUAL (SUB1 M) M1)
- (IF (NULL RES2) (RETURN NIL))
- (SETQ RES1 RES
- PARTRES (ADD (AUGMULT (MUL -1
- (POWER (POLFOO C B 0 X)
- R12)
- (R1M M)
- (EXT-1M X M)))
- (AUGMULT (MUL B R12 (R1M M) RES1))
- (AUGMULT (MUL C (R1M M) RES2))))
- (GO ON)))
- (GO JUMP4)
- JUMP5 (SETQ M CONTROLPOW)
- (COND ((ZEROP M)
- (SETQ PARTRES (MUL* EXP1 (LIST '(%LOG) X)))
- (GO ON)))
- (SETQ PARTRES (MUL -1 EXP1 (EXT-1M X M) (R1M M)))
- ON (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES))))
- LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST))
- (COND ((NULL NEGPOWLIST) (RETURN RESULT)))
- (SETQ COEF (CADAR NEGPOWLIST) CONTROLPOW (CAAR NEGPOWLIST))
- (COND ((EQUAL COUNT 5) (GO JUMP5)))
- (COND ((EQUAL COUNT 1) (GO JUMP1)))
- (COND ((EQUAL COUNT 2) (GO JUMP2)))
- (COND ((EQUAL COUNT 3) (GO JUMP3)))
- (SETQ M1 (PLUS CONTROLPOW -2))
- (COND ((EQUAL M1 M) (SETQ RES2 RES1)))
- (GO JUMP4)))
- (POWER C (LIST '(RAT) -1 2)) (POWER B -1)))
-
- (DEFUN PMM-1 (M) (PLUS M M -1))
-
- (DEFUN R1M (M) (LIST '(RAT) 1 M))
-
- (DEFUN EXT-1M (X M) (POWER X (TIMES -1 M)))
-
- (DEFUN CASE0 (POWER C B X)
- ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EB-1)
- (PROG (SIGNC P RESULT)
- (SETQ SIGNC (CHECKSIGNTM EC-1) P 1)
- (COND ((EQ SIGNC '$POSITIVE)
- (SETQ RESULT
- (ADD (AUGMULT (MUL EXP1 EC-1 EXP2
- (POWER (POLFOO C B 0 X)
- R12)))
- (AUGMULT (MUL* B B (LIST '(RAT) -1 8)
- EXP3
- (LIST '(%LOG)
- (ADD EXP2
- (MUL 2
- (POWER C R12)
- (POWER
- (POLFOO C B 0 X)
- R12))))))))))
- (COND ((EQ SIGNC '$NEGATIVE)
- (SETQ RESULT
- (ADD (AUGMULT (MUL EXP1 EC-1 EXP4
- (POWER (POLFOO (MUL -1 C)
- B 0 X)
- R12)))
- (AUGMULT (MUL* B B (LIST '(RAT) 1 8)
- EXP3
- (LIST '(%ASIN)
- (MUL EB-1 EXP4))))))))
- LOOP (COND ((EQUAL POWER P) (RETURN RESULT)))
- (SETQ P (PLUS P 2)
- RESULT ((LAMBDA (EXP5)
- (ADD (AUGMULT (MUL R12 EC-1 EXP5 EXP2
- (POWER (POLFOO C B 0 X)
- (LIST '(RAT) P 2))))
- (AUGMULT (MUL P B B (LIST '(RAT) -1 4)
- EC-1 EXP5 RESULT))))
- (INV (PLUS P 1))))
- (GO LOOP)))
- (LIST '(RAT) 1 4) (ADD B (MUL 2 C X)) (POWER C (LIST '(RAT) -3 2))
- (ADD (MUL 2 C X)(MUL -1 B)) (POWER B -1)))
-
- (DEFUN DEN1NUMN (P C B A X)
- (COND ((EQUAL P 1)
- (ADD (POWER (POLFOO C B A X) R12 )
- (AUGMULT (MUL A (DEN1DEN1 C B A X)))
- (AUGMULT (MUL B R12 (DEN1 C B A X)))))
- (T (ADD (AUGMULT (MUL (POWER (POLFOO C B A X)
- (ADD P (LIST '(RAT) -1 2)))
- (INV (PLUS P P -1))))
- (AUGMULT (MUL A (DEN1NUMN (PLUS P -1) C B A X)))
- (AUGMULT (MUL B R12 (NUMN (PLUS P -2) C B A X)))))))
-
- (DEFUN DISTRINT (EXPR X)
- (COND ((NULL EXPR) 0)
- (T (ADD (INTIRA (CAR EXPR) X)
- (DISTRINT (CDR EXPR) X)))))
-
-